Amiga Collections: Franz PD/Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip/Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf/Source.zip/Calls.p

Text File | 1989-11-26 | 16KB | 627 lines

External;

{
    Calls.p (of PCQ Pascal)
    Copyright (c) 1989 Patrick Quaid

    Calls.p is the first attempt to organize the various
addressing and code generating routines in one section.  If you
read the other sections you'll find that not much effort went into
this project.  Nonetheless, a couple of common addressing things
can be found here.
    If the compiler were designed so that all the addressing
things were here, it would be much easier to port to a different
processor.
}

{$O-}
{$I "Pascal.i"}

    Function Match(s : Symbols) : Boolean;
        external;
    Procedure Error(s : string);
        external;
    Function FindField(s : string; TP : TypePtr): IDPtr;
        external;
    Function FindWithField(S : String) : IDPtr;
        External;
    Procedure NextSymbol;
        external;
    Function Expression() : TypePtr;
        external;
    Function TypeCheck(t1, t2 : TypePtr): Boolean;
        external;
    Function TypeCmp(t1, t2 : TypePtr) : Boolean;
        external;
    Function FindID(s : string) : IDPtr;
        external;
    Function IsVariable(i : IDPtr) : Boolean;
        external;
    Function GetLabel() : Integer;
        external;
    Procedure PrintLabel(l : Integer);
        external;
    Procedure ns;
        external;
    Function Suffix(s : Integer): Char;
        external;
    Procedure Mismatch;
        external;
    Function SimpleType(t : TypePtr): Boolean;
        external;
    Function NumberType(t : TypePtr): Boolean;
        external;
    Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
        external;

Procedure PushLongD0;
begin
    writeln(OutFile, "\tmove.l\td0,-(sp)");
    StackLoad := StackLoad + 4;
end;

Procedure PopLongD0;
begin
    Writeln(OutFile, '\tmove.l\t(sp)+,d0');
    StackLoad := StackLoad - 4;
end;

Procedure PopStackSpace(amount : Integer);
begin
    Writeln(OutFile, '\tadd.l\t#', amount, ',sp');
    StackLoad := StackLoad - amount;
end;

Procedure PushWordD0;
begin
    writeln(OutFile, "\tmove.w\td0,-(sp)");
    StackLoad := StackLoad + 2;
end;

Procedure PushLongD1;
begin
    Writeln(OutFile, '\tmove.l\td1,-(sp)');
    StackLoad := StackLoad + 4;
end;

Procedure PopLongD1;
begin
    writeln(OutFile, "\tmove.l\t(sp)+,d1");
    StackLoad := StackLoad - 4;
end;

Procedure PushLongA0;
begin
    writeln(OutFile, '\tmove.l\ta0,-(sp)');
    StackLoad := StackLoad + 4;
end;

Procedure PopLongA0;
begin
    writeln(OutFile, '\tmove.l\t(sp)+,a0');
    StackLoad := StackLoad - 4;
end;

Procedure PopLongA1;
begin
    writeln(OutFile, '\tmove.l\t(sp)+,a1');
    StackSpace := StackSpace - 4;
end;

Procedure DoRangeCheck(VarType : TypePtr);

{
    This routine is called from selector() when range checking
is turned on.  Notice that the code is now in a library, rather
than inline as it was in 1.0.  Also note that the library code fixes
the stack after the call.
}

begin
    Writeln(OutFile, '\tpea\t', VarType^.Lower);
    Writeln(OutFile, '\tpea\t', VarType^.Upper);
    Writeln(OutFile, '\tjsr\t_p%CheckRange');
end;

Function GetFramePointer(Reference : Integer) : Short;
var
    Current : Integer;
begin
    Current := CurrentBlock^.Level;
    if Current = Reference then
    GetFramePointer := 5
    else begin
    writeln(OutFile, "\tmove.l\t8(a5),a4");
    Current := Pred(Current);
    while Current > Reference do begin
        Writeln(OutFile, "\tmove.l\t8(a4),a4");
        Current := Pred(Current);
    end;
    GetFramePointer := 4;
    end;
end;

Procedure GetPointerVal(ID : IDPtr);

{
    This routine puts the value of a pointer variable (or a
reference parameter) into a0.
}
var
    Reg : Short;
begin
    case ID^.Object of
    global : writeln(OutFile, "\tmove.l\t_", ID^.Name, ',a0');
    typed_const :
         if ID^.Level <= 1 then
             writeln(OutFile, '\tmove.l\t_', ID^.Name, ',a0')
         else
             writeln(OutFile, '\tmove.l\t_',ID^.Name,'%',ID^.Unique);
    refarg : begin
            Reg := GetFramePointer(ID^.Level);
            writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
            writeln(OutFile, "\tmove.l\t(a0),a0");
         end;
    else begin
        Reg := GetFramePointer(ID^.Level);
        writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
     end;
    end;
end;

Procedure SimpleAddress(ID : IDPtr);

{
    simpleaddress() is passed a idrecord of some sort of
variable, and just loads its address into a0.
}
var
    Reg : Short;
begin
    case ID^.Object of
    global : writeln(OutFile, "\tlea\t_", ID^.Name, ',a0');
    typed_const :
         if ID^.Level <= 1 then
             writeln(OutFile, '\tlea\t_', ID^.Name, ',a0')
         else
             writeln(OutFile, '\tlea\t_', ID^.Name, '%',
                ID^.Unique, ',a0');
    refarg : begin
            Reg := GetFramePointer(ID^.Level);
            writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
         end;
    else begin
         Reg := GetFramePointer(ID^.Level);
         writeln(OutFile, "\tlea\t", ID^.Offset, '(a', Reg, '),a0');
     end;
    end;
end;

Procedure DoMultiply(size : Integer);

    Procedure ShiftLeft(num : Short);
    begin
    Writeln(OutFile, "\tlsl.l\t#", num, ',d0');
    end;

begin
    case size of
    1  : ;
    2  : ShiftLeft(1);
    4  : ShiftLeft(2);
    8  : ShiftLeft(3);
    16 : ShiftLeft(4);
    32 : ShiftLeft(5);
    64 : ShiftLeft(6);
    128: ShiftLeft(7);
    256: ShiftLeft(8);
    else
    writeln(OutFile, "\tmuls\t#", size, ',d0');
    end;
end;

Function Selector(ID : IDPtr) : TypePtr;

{
    This is an overlarge function that handles all the
selectors- in other words ^, ., and [].  It can handle a series of
them, of course.  selector() returns Nil if no selection was
required, and the type if there was some selection.
}

var
    VarType    : TypePtr;
    FieldID    : IDPtr;
    IndexType    : TypePtr;
    Stacked    : Boolean;
    Leave    : Boolean;
    bufsize,
    WithOffset    : Integer;
    Substitute    : TypePtr;
begin
    if ID^.Object = field then begin
    WithOffset := StackLoad - LastWith^.Offset;
    if WithOffset = 0 then
        Writeln(OutFile, '\tmove.l\t(sp),a0')
    else
        Writeln(OutFile, '\tmove.l\t', WithOffset, '(sp),a0');
    if ID^.Offset <> 0 then
        Writeln(OutFile, '\tadda.l\t#', ID^.Offset, ',a0');
    Stacked := True;
    end else
    Stacked := False;
    VarType := ID^.VType;
    while (CurrSym = period1) or (CurrSym = leftbrack1) or
      (CurrSym = carat1) do begin
    if (not Stacked) and (VarType^.Object <> ob_pointer) then begin
        SimpleAddress(ID);
        Stacked := True;
    end;
    if Match(Period1) then begin
        if VarType^.Object <> ob_record then
        error("not a record type");
        FieldID := FindField(symtext, VarType);
        if FieldID = Nil then
        Error("unknown field")
        else if FieldID^.Offset <> 0 then
        writeln(OutFile, "\tadda.l\t#", FieldID^.Offset, ',a0');
        NextSymbol;
        VarType := FieldID^.VType;
    end else if Match(Carat1) then begin
        if VarType^.Object = ob_file then begin
        BufSize := VarType^.SubType^.Size;
        writeln(OutFile, '\tjsr\t_p%FilePtr');
        if IOCheck then
            Writeln(OutFile, '\tjsr\t_p%CheckIO');
        VarType := VarType^.SubType;
        end else if VarType^.Object = ob_pointer then begin
        if not Stacked then begin
            GetPointerVal(ID);
            Stacked := True;
        end else
            writeln(OutFile, "\tmove.l\t(a0),a0");
        VarType := VarType^.SubType;
        end else
        error("Need a file or pointer for ^");
    end else if Match(LeftBrack1) then begin
        if VarType^.Object = ob_array then begin
        Leave := False;
        repeat
            PushLongA0;
            IndexType := Expression();
            Substitute := Indextype;
            PromoteType(Substitute, Inttype, 0);
            if RangeCheck then
            DoRangeCheck(VarType);
            if not TypeCheck(IndexType, VarType^.Ref) then
            Mismatch;
            if VarType^.Lower <> 0 then
            writeln(OutFile, "\tsub.l\t#", VarType^.Lower, ',d0');
            VarType := VarType^.SubType;
            DoMultiply(VarType^.Size);
            PopLongA0;
            writeln(OutFile, "\tadd.l\td0,a0");
            if Match(Comma1) then begin
            if VarType^.Object <> ob_array then begin
                Error("Not a multidimensional array");
                Leave := True;
            end;
            end else
            Leave := True;
        until Leave;
        if not Match(RightBrack1) then
            Error("Expecting ]");
        end else if TypeCheck(Vartype, StringType) then begin
        if not Stacked then begin
            GetPointerVal(ID);
            Stacked := True;
        end else
            writeln(OutFile, "\tmove.l\t(a0),a0");
        PushLongA0;
        IndexType := Expression();
        if not TypeCheck(IndexType, IntType) then
            Mismatch
        else
            PromoteType(IndexType, IntType, 0);
        if not Match(RightBrack1) then
            error("expecting ]");
        PopLongA0;
        writeln(OutFile, "\tadd.l\td0,a0");
        VarType := CharType;
        end else
        error("Expecting an Array or String");
    end;
    end;
    if Stacked then
    Selector := VarType
    else
    Selector := Nil;
end;

Function LoadAddress() : TypePtr;

{
    This is the routine used wherever I need the address of a
variable, for example reference parameters or the adr() function.
The address is loaded into a0.
}

var
    ArgIndex    : IDPtr;
    ArgType    : TypePtr;
begin
    if CurrSym = Ident1 then begin
    ArgIndex := FindWithField(SymText);
    if ArgIndex = Nil then
        ArgIndex := FindID(SymText);
    NextSymbol;
    if ArgIndex = Nil then begin
        error("Unknown ID");
        LoadAddress := BadType;
    end else begin
        if IsVariable(ArgIndex) then begin
        ArgType := Selector(ArgIndex);
        if ArgType = Nil then begin
            SimpleAddress(ArgIndex);
            LoadAddress := ArgIndex^.VType
        end else
            LoadAddress := ArgType;
        end else if (ArgIndex^.Object = proc) or
            (ArgIndex^.Object = func) then begin
        with ArgIndex^ do begin
            if Level <= 1 then
            Writeln(OutFile, "\tlea\t_", Name, ',a0')
            else
            Writeln(OutFile, "\tlea\t_", Name, '%', Unique, ',a0');
        end;
        LoadAddress := AddressType;
        end else
        error("Expecting a variable (reference parameter)");
    end
    end else
    error("Expecting a variable identifier");
    LoadAddress := BadType;
end;

Procedure PushArgs(ProcID : IDPtr);

{
    This routine handles the parameters of a call (not the
declaration, which is handled in doblock()).  It sorts out the
various reference and value parameters and gets the stack properly
set up.
}

var
    CurrentParam    : IDPtr;
    stay        : Boolean;
    argtype        : TypePtr;
    argindex        : integer;
    totalsize        : integer;
    lab            : integer;
begin
    Stay := True;
    if Match(LeftParent1) then begin
    CurrentParam := ProcID^.Param;
    while (not Match(RightParent1)) and Stay do begin
        if CurrentParam = Nil then begin
        error("argument not expected");
        nextsymbol;
        Stay := False;
        end else begin
        if CurrentParam^.Object = valarg then begin
            ArgType := Expression();
            if not TypeCheck(ArgType, CurrentParam^.VType) then begin
            Mismatch;
            ArgType := BadType;
            end else begin
            if NumberType(ArgType) then
                PromoteType(ArgType, CurrentParam^.VType, 0);
            ArgType := CurrentParam^.VType;
            if SimpleType(ArgType) then begin
                if ArgType^.Size <= 2 then
                PushWordD0
                else if ArgType^.Size = 4 then
                PushLongD0;
            end else begin
                writeln(OutFile, "\tmove.l\td0,a0");
                writeln(OutFile, "\tmove.l\tsp,a1");
                writeln(OutFile, "\tsub.l\t#",
                ArgType^.Size, ',a1');
                writeln(OutFile, "\tmove.l\t#",
                ArgType^.Size - 1, ',d1');

                lab := GetLabel();
                PrintLabel(lab);
                writeln(OutFile, "\tmove.b\t(a0)+,d0");
                writeln(OutFile, "\tmove.b\td0,(a1)+");
                write(OutFile, "\tdbra\td1,");
                PrintLabel(lab);
                writeln(OutFile);
                write(OutFile, "\tsub.l\t#");
                if odd(ArgType^.Size) then begin
                write(OutFile, ArgType^.Size + 1);
                StackLoad := StackLoad + ArgType^.Size + 1;
                end else begin
                write(OutFile, ArgType^.Size);
                StackLoad := StackLoad + ArgType^.Size;
                end;
                writeln(OutFile, ',sp');
            end;
            end;
        end else if CurrentParam^.Object = refarg then begin
            if CurrSym = ident1 then begin
            ArgType := LoadAddress();
            PushLongA0;
            if not TypeCmp(ArgType, CurrentParam^.VType) then
                Mismatch;
            end else
            error("Expecting a variable name (reference param)");
        end;
        CurrentParam := CurrentParam^.Next;
        if CurrentParam <> Nil then
            if not Match(Comma1) then
            error("Expected ,");
        end;
    end;
    if CurrentParam <> Nil then
        error("more parameters needed");
    end else begin
    if ProcID^.Param <> Nil then
        error("Expecting some parameters");
    end
end;

Procedure PushFrame(Callee : Integer);
var
    Caller : Integer;
begin
    if Callee <= 1 then { global-level routines, which include externs }
    return
    else begin
    Caller := CurrentBlock^.Level - 1;
    if Callee = Caller + 1 then { calling child procedure }
        writeln(OutFile, "\tmove.l\ta5,-(sp)")
    else if Callee = Caller then { same level }
        writeln(OutFile, "\tmove.l\t8(a5),-(sp)")
    else begin
        writeln(OutFile, "\tmove.l\t8(a5),a4");
        Caller := Pred(Caller);
        while Caller > Callee do begin
        writeln(OutFile, "\tmove.l\t8(a4),a4");
        Caller := Pred(Caller);
        end;
        writeln(OutFile, "\tmove.l\t8(a4),-(sp)");
    end;
    StackLoad := StackLoad + 4;
    end;
end;

Procedure CallFunc(FuncID : IDPtr);

{
    This calls a function.  It's mostly the same as callproc,
but it's called from deep within expression() rather than
statement().  This will also have to push a back pointer.
}
var
    ArgSize : Integer;
    BaseOffset : Integer;
begin
    PushArgs(FuncID);
    PushFrame(FuncID^.Level);
    if FuncID^.Level <= 1 then
    writeln(OutFile, "\tjsr\t_", FuncID^.Name)
    else
    Writeln(OutFile, "\tjsr\t_", FuncID^.Name, '%', FuncID^.Unique);
    if FuncID^.Param <> Nil then begin
    if FuncID^.Param^.Object = refarg then
        ArgSize := FuncID^.Param^.Offset - 4
    else
        ArgSize := FuncID^.Param^.Offset - 8 +
            FuncID^.Param^.VType^.Size;
    end else begin
    if FuncID^.Level <= 1 then
        ArgSize := 0
    else
        ArgSize := 4;
    end;
    if ArgSize <> 0 then begin
    if odd(ArgSize) then
        ArgSize := Succ(ArgSize);
    PopStackSpace(ArgSize);
    end;
end;

Procedure CallProc(ProcID : IDPtr);

var
    ArgSize : Integer;
begin
    NextSymbol;
    CallFunc(ProcID);
end;

Procedure SaveThrougha0(TotalSize : Integer);

{
    This saves a complex data object pointed to by d0 to the
memory at a0.
}

var
    lab        : integer;
begin
    writeln(OutFile, "\tmove.l\td0,a1");
    writeln(OutFile, "\tmove.l\t#", TotalSize - 1, ',d1');
    lab := GetLabel();
    PrintLabel(lab);
    writeln(OutFile, "\tmove.b\t(a1)+,d0");
    writeln(OutFile, "\tmove.b\td0,(a0)+");
    write(OutFile, "\tdbra\td1,");
    PrintLabel(lab);
    writeln(OutFile);
end;

Procedure SaveStack(TP : TypePtr);

{
    This saves a variable into the memory pointed to by the
longword on the top of the stack.  Odd as it may sound, this occurs
fairly often.
}

begin
    PopLongA0;
    if SimpleType(TP) then
    writeln(OutFile, "\tmove.", suffix(TP^.Size), "\td0,(a0)")
    else
    SaveThrougha0(TP^.Size);
end;

Procedure SaveVal(ID : IDPtr);

{
    This saves whatever's in d0 into the variable pointed to by
ID.
}

var
    TotalSize    : Integer;
    Reg : Short;
begin
    TotalSize := ID^.VType^.Size;
    if (ID^.Object = global) or (ID^.Object = typed_const) then begin
    if SimpleType(ID^.VType) then begin
        if ID^.Level > 1 then { only for typed_const, of course }
        writeln(OutFile, '\tmove.', Suffix(TotalSize), '\td0,_',
                ID^.Name, '%', ID^.Unique)
        else
        writeln(OutFile, "\tmove.", Suffix(TotalSize),
                "\td0,_", ID^.Name)
    end else begin
        if ID^.Level > 1 then { only for typed_const, of course }
        writeln(OutFile, '\tlea\t_',ID^.Name,'%',ID^.Unique,',a0')
        else
        writeln(OutFile, "\tlea\t_", ID^.Name, ',a0');
        SaveThrougha0(TotalSize);
    end;
    end else if (ID^.Object = local) or (ID^.Object = valarg) then begin
    Reg := GetFramePointer(ID^.Level);
    if SimpleType(ID^.VType) then
        writeln(OutFile, "\tmove.", Suffix(TotalSize), "\td0,",
            ID^.Offset, '(a', Reg, ')')
    else begin
        writeln(OutFile, "\tlea\t", ID^.Offset, '(a', Reg, '),a0');
        savethrougha0(totalsize);
    end;
    end else begin
    Reg := GetFramePointer(ID^.Level);
    writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
    if SimpleType(ID^.VType) then
        writeln(OutFile, "\tmove.", Suffix(TotalSize), "\td0,(a0)")
    else
        SaveThrougha0(TotalSize);
    end;
end;